home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / FOOLS / !Fl / scm / extra < prev    next >
Text File  |  1994-11-19  |  9KB  |  291 lines
  1. ;;; extra functions and macros
  2.   
  3. (define (list-ref l k)
  4.   ;; kth element of l
  5.   (and (pair? l) (if (<= k 0) (car l) (list-ref (cdr l) (- k 1)))))
  6.  
  7. (define (list-tail l k)
  8.   ;; sublist of l omitting the first k elements
  9.   (and (pair? l) (if (<= k 0) l (list-tail (cdr l) (- k 1)))))
  10.  
  11. (define (last-pair l)
  12.   ;; the last pair of the list
  13.   (if (pair? (cdr l)) (last-pair (cdr l)) l))
  14.  
  15. (define (append! a b)
  16.   (if (null? a) b (begin (set-cdr! (last-pair a) b) a)))
  17.  
  18. ;; ASCII based character predicates
  19. (define (char-upper-case? c) (and (char>=? c #\A) (char<=? c #\Z)))
  20. (define (char-lower-case? c) (and (char>=? c #\a) (char<=? c #\z)))
  21. (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
  22. (define (char-numeric? c) (and (char>=? c #\0) (char <=? c #\9)))
  23. (define (char-whitespace? c) (memv c '(#\space #\tab #\newline)))
  24. (define (char-upcase c) (if (char-lower-case? c) (integer->char (- c 32)) c))
  25. (define (char-downcase c) (if (char-upper-case? c) (integer->char (+ c 32)) c))
  26.  
  27. (define gensym
  28.   ;; generate unique symbols
  29.   (let ((counter 0))
  30.     (lambda () (begin1
  31.         (string->uninterned-symbol
  32.          (string-append "G" (integer->string counter #\d)))
  33.         (set! counter (+ counter 1))))))
  34.  
  35. (define-macro (while pred . body)
  36.   ;; while pred is true, evaluate the expressions in body and return the
  37.   ;; result of the last expression evaluated (or #f if none were evaluated)
  38.   (let ((while-loop (gensym))
  39.     (while-res (gensym)))
  40.     `(letrec ((,while-loop
  41.            (lambda (,while-res)
  42.          (if ,pred (,while-loop (begin ,@body)) ,while-res))))
  43.        (,while-loop #f))))
  44.  
  45. (define-macro (when pred . body)
  46.   ;; evaluate body if pred is true
  47.   `(and ,pred (begin ,@body)))
  48.  
  49. (define-macro (unless pred . body)
  50.   ;; evaluate body if pred is false
  51.   `(or ,pred (begin ,@body)))
  52.  
  53. (define-macro (case key . clauses)
  54.   ;; conditionally execute the clause eqv? to key
  55.   (define (case-make-clauses key)
  56.     `(cond ,@(map
  57.               (lambda (clause)
  58.                 (if (pair? clause)
  59.                     (let ((case (car clause))
  60.                           (exprs (cdr clause)))
  61.                       (cond ((eq? case 'else)
  62.                              `(else ,@exprs))
  63.                             ((pair? case)
  64.                              (if (= (length case) 1)
  65.                                  `((eqv? ,key ',(car case)) ,@exprs)
  66.                                  `((memv ,key ',case) ,@exprs)))
  67.                             (else
  68.                              `((eqv? ,key ',case) ,@exprs))))
  69.                     (error 'case "invalid syntax in ~a" clause)))
  70.               clauses)))
  71.   (if (pair? key)
  72.       (let ((newkey (gensym)))
  73.         `(let ((,newkey ,key))
  74.            ,(case-make-clauses newkey)))
  75.       (case-make-clauses key)))
  76.  
  77. (define-macro (let* bindings . body)
  78.   ;; sequentially perform the bindings then evaluate the expressions in body
  79.   ;; within the new scope defined by the bindings
  80.   (if (null? bindings)
  81.       `(let () ,@body)
  82.       `(let ((,(caar bindings) ,(cadar bindings)))
  83.      (let* ,(cdr bindings) ,@body))))
  84.  
  85. (define-macro (let bindings .  body)
  86.   ;; extend let to handle (let name bindings expr ...)
  87.   (if (symbol? bindings)
  88.       ;; named let
  89.       `(letrec ((,bindings
  90.          (lambda ,(map car (car body)) ,@(cdr body))))
  91.      (,bindings ,@(map cadr (car body))))
  92.       `((lambda ,(map car bindings) ,@body) ,@(map cadr bindings))))
  93.  
  94. (define list-join
  95.   ;; pair-wise join the lists in lsts (the output is in reverse order)
  96.   (letrec ((join-iter
  97.         (lambda (lsts out)
  98.           (if (ormap null? lsts)
  99.           out
  100.           (join-iter (map cdr lsts) (cons (map car lsts) out))))))
  101.     (lambda (lsts) (join-iter lsts '()))))
  102.  
  103. (define map
  104.   ;; redefine map to handle multiple argument lists
  105.   (letrec ((map-loop
  106.         (lambda (fcn lst out)
  107.           (if (null? lst)
  108.           out
  109.           (map-loop fcn (cdr lst) (cons (fcn (car lst)) out))))))
  110.     (lambda (fcn lst . rest)
  111.       (if (null? rest)
  112.       (reverse (map-loop fcn lst '()))
  113.       (map-loop (lambda (x) (apply fcn x))
  114.             (list-join (cons lst rest))
  115.             '())))))
  116.  
  117. (define for-each
  118.   ;; redefine for-each to handle multiple argument lists
  119.   (letrec ((for-loop
  120.         (lambda (fcn lst)
  121.           (if (null? lst)
  122.           #t
  123.           (begin (fcn (car lst)) (for-loop fcn (cdr lst)))))))
  124.     (lambda (fcn lst . rest)
  125.       (if (null? rest)
  126.       (for-loop fcn lst)
  127.       (for-loop (lambda (x) (apply fcn x))
  128.             (reverse (list-join (cons lst rest))))))))
  129.  
  130. (define ormap
  131.   (letrec ((ormap1
  132.         (lambda (pred lst last)
  133.           (or last
  134.           (and (pair? lst)
  135.                (ormap1 pred (cdr lst) (pred (car lst))))))))
  136.     (lambda (pred lst . rest)
  137.       (if (null? rest)
  138.       (ormap1 pred lst #f)
  139.       (ormap1 (lambda (x) (apply pred x))
  140.           (reverse (list-join (cons lst rest)))
  141.           #f)))))
  142.  
  143. (define andmap
  144.   (letrec ((andmap1
  145.         (lambda (pred lst last)
  146.           (if last
  147.           (if (pair? lst)
  148.               (andmap1 pred (cdr lst) (pred (car lst)))
  149.               last)))))
  150.     (lambda (pred lst . rest)
  151.       (if (null? rest)
  152.       (andmap1 pred lst #t)
  153.       (andmap1 (lambda (x) (apply pred x))
  154.            (reverse (list-join (cons lst rest)))
  155.            #t)))))
  156.  
  157. (define (string . chars)
  158.   ;; build a string out of the characters in chars
  159.   (list->string chars))
  160.  
  161. (define duplicates
  162.   ;; find the duplicates in a list using eq?
  163.   (letrec ((dupes
  164.         (lambda (l f d)
  165.           (if (null? l) d
  166.           (let ((elt (car l)))
  167.             (if (memq elt f)
  168.             (if (memq elt d)
  169.                 (dupes (cdr l) f d)
  170.                 (dupes (cdr l) f (cons elt d)))
  171.             (dupes (cdr l) (cons elt f) d)))))))
  172.     (lambda (l) (dupes l '() '()))))
  173.  
  174. ;; the top-level environment
  175. (define user-initial-environment (package-environment 'top-level))
  176.  
  177. ;;; streams
  178.  
  179. (define-macro delay
  180.   (letrec ([make-promise
  181.         (lambda (proc)
  182.           (let ((already-run? #f) (result #f))
  183.         (lambda ()
  184.           (if already-run? result
  185.               (begin (set! result (proc))
  186.                  (set! already-run? #t)
  187.                  result)))))])
  188.     (lambda (expr) `(,make-promise (lambda () ,expr)))))
  189.  
  190. (define (force expr) (expr))
  191.  
  192. (define-macro (cons-stream head tail) `(cons ,head (delay ,tail)))
  193. (define head car)
  194. (define (tail stream) (force (cdr stream)))
  195. (define the-empty-stream nil)
  196. (define empty-stream? null?)
  197.  
  198. (define (nth-stream n s)
  199.   (and (pair? s) (if (< n 1) (head s) (nth-stream (- n 1) (tail s)))))
  200.  
  201. (define (map-stream fcn s)
  202.   (if (empty-stream? s) the-empty-stream
  203.       (cons-stream (fcn (head s)) (map-stream fcn (tail s)))))
  204.  
  205. (define (filter-stream pred s)
  206.   (cond ((empty-stream? s) the-empty-stream)
  207.     ((pred (head s)) (cons-stream (head s) (filter-stream pred (tail s))))
  208.     (else (filter-stream pred (tail s)))))
  209.  
  210. ;; printf and fprintf
  211. (define (vfprintf file fmt args)
  212.   (letrec ((len (string-length fmt))
  213.        (get-arg
  214.         (lambda ()
  215.           (if (null? args)
  216.           (error 'vfprintf "missing arguments")
  217.           (begin1 (car args) (set! args (cdr args))))))
  218.        (process
  219.         (lambda (ptr)
  220.           (if (< ptr len)
  221.           (let ((c (string-ref fmt ptr)))
  222.             (cond [(char=? c #\~)
  223.                (case (string-ref fmt (+ ptr 1))
  224.                  [#\s (write (get-arg) file)]
  225.                  [#\a (display (get-arg) file)]
  226.                  [#\c (write-char (get-arg) file)]
  227.                  [#\% (newline file)]
  228.                  [#\~ (write-char #\~ file)]
  229.                  [else
  230.                   (write-char (string-ref fmt (+ ptr 1)) file)])
  231.                (process (+ ptr 2))]
  232.               [else
  233.                (write-char c file)
  234.                (process (+ ptr 1))]))
  235.           (if (not (null? args))
  236.               (error 'vfprintf "supplied extra arguments ~s" args))))))
  237.     (process 0)))
  238. (define (fprintf file fmt . args) (vfprintf file fmt args))
  239. (define (printf fmt . args) (vfprintf (current-output-port) fmt args))
  240.  
  241. (define (error proc fmt . args)
  242.   (printf "~%~a:  " proc)
  243.   (vfprintf (current-output-port) fmt args)
  244.   (newline)
  245.   (abort))
  246.  
  247. ;;; packages
  248.  
  249. ;; where to look for packages (include a trailing slash)
  250. ;; --- ams fiddled.
  251. ; (define *package-path* '("./" "~/scm/" "/usr/share/new/lib/fools/"))
  252. (define *package-path* '("<Fools$Path>.scm." "@."))
  253.  
  254. ;; file extension for packages
  255. ; --- ams we dont have file extensions ;-)
  256. ; (define *package-ext* ".scm")
  257. (define *package-ext* "")
  258.  
  259. ;; packages loaded
  260. (define *packages* '())
  261.  
  262. ;; if true print name of package when loaded
  263. (define *load-verbose* #t)
  264.  
  265. (define (find-package package)
  266.   ;; find the file name of package
  267.   (define (for-each-path paths)
  268.     (if (null? paths) #f
  269.     (let ((fname (string-append (car paths) package)))
  270.       (if (file-access fname "r") fname
  271.           (for-each-path (cdr paths))))))
  272.   (for-each-path *package-path*))
  273.  
  274. (define (require package)
  275.   ;; load package if not already loaded
  276.   (if (memq package *packages*) #t
  277.       (let ((filename (find-package (string-append package *package-ext*))))
  278.     (if filename
  279.         (begin
  280.           (when *load-verbose*
  281.         (printf "; loading ~s~%" filename))
  282.           (load filename))
  283.         (error 'require "can't find package ~s in ~s"
  284.            package  *package-path*)))))
  285.  
  286. (define (provide package)
  287.   ;; note somewhere that package is loaded
  288.   (if (memq package *packages*)
  289.       (error 'provide "package ~s is already loaded" package)
  290.       (begin (set! *packages* (cons package *packages*)) #t)))
  291.